;;; functionality for the server side of the model interface
(defpackage :experiment.model-server
  (:use :cl)
  (:nicknames :model-server)
  (:export :start
           :dump-screen
           :execute-action
           :main-screen
           :list-sessions
           :list-options
           :start-session
           :disable-timers
           :*package-list*))

(defpackage :model
  (:use :cl))

(in-package :experiment.model-server)

(defvar *server* nil)

(defvar *package-list* (list (find-package :experiment))
  "The list of packages used to search for symbols.")

(defun poll-clients ()
  (remote-eval:poll *server*))

(defun start ()
  (handler-case
      (progn
        (unless *server*
          (setf *server* (remote-eval:start)))
        (gwee:add-hook (gwee:event-poll-hook gwee:*top-view*) 'poll-clients)
        t)
    (usocket:socket-error (c)
      c)))

(defun clean-up-symbols (tree)
  (cond
    ((keywordp tree)
     tree)
    ((symbolp tree)
     (let ((sym (intern (symbol-name tree) :model)))
       sym))
    ((listp tree)
     (mapcar 'clean-up-symbols tree))
    (t
     tree)))

(defun search-for-symbol (symbol &optional (packages *package-list*))
  (or (dolist (p packages)
        (multiple-value-bind (sym status) (find-symbol (string symbol) p)
          (when (eq status :external)
            (return sym))))
      symbol))

(defun remap-symbols (tree &optional (packages *package-list*))
  (cond
    ((keywordp tree)
     tree)
    ((symbolp tree)
     (search-for-symbol tree packages))
    ((listp tree)
     (mapcar 'remap-symbols tree))
    (t
     tree)))

(defun dump-screen ()
  (assert exp:*experiment* () "The experiment has not yet begun.")
  (clean-up-symbols
   `(:state ,(when (exp:current-state exp:*experiment*)
                   (type-of (exp:current-state exp:*experiment*)))
            :objects ,(exp:state-list-objects exp:*experiment* (exp:current-state exp:*experiment*))
            :actions ,(exp:state-list-actions exp:*experiment* (exp:current-state exp:*experiment*)))))

(defun execute-action (action-name &rest args &key &allow-other-keys)
  (assert exp:*experiment* () "The experiment has not yet begun.")
  (clean-up-symbols
   (apply 'exp:state-translate-action
          (exp:current-state exp:*experiment*)
          (search-for-symbol action-name)
          args)))

(defun main-screen ()
  (throw 'exp::restart nil))

(defun list-sessions (id)
  (assert exp::*main-screen* () "You are not in the main screen.")
  (let ((resumable (probe-file (exp::get-suspend-file id))))
    (append (mapcar 'first (exp::main-screen-sessions exp::*main-screen*))
            (when resumable (list :resume)))))

(defun list-options ()
  (loop for i in (exp::main-screen-options exp::*main-screen*)
     collect (cons (exp:option-name i) (copy-list (exp:option-values i)))))

(defun verify-options (options)
  "return any options that have bad values or don't exist."
  (loop for o = options then (cddr o) while o
     for name = (first o)
     for value = (second o)
     for option = (find name (exp::main-screen-options exp::*main-screen*) :key 'exp:option-name)
     unless (and option
                 (find value (exp:option-values option)))
     collect name))

(defun start-session (id session &rest options)
  (assert exp::*main-screen* () "You are not in the main screen.")
  (let ((session-name (find session (list-sessions id) :test 'equal))
        (bad-options (verify-options options)))
    (assert session-name
            ()
            "Cannot find \"~a\" among sessions: ~s"
            session
            (list-sessions id))
    (assert (null bad-options)
            ()
            "The following options don't exist or have bad values: ~s" bad-options)
    ;; set the options
    (loop for o = options then (cddr o) while o
       for name = (first o)
       for value = (second o)
       for option = (find name (exp::main-screen-options exp::*main-screen*) :key 'exp:option-name)
       do (setf (exp:option-value option) value))
    (throw 'exp::done (values id session-name))))

(defun disable-timers ()
  (assert exp:*experiment* () "The experiment has not yet begun.")
  (gwee:cancel-all-timers)
  (setf (exp:experiment-disable-timers-p exp:*experiment*) t))
